home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / INTB.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  47KB  |  1,857 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. /* Continuation of ada interpreter - auxiliary procedures */
  11.  
  12. /* Include standard header modules */
  13. #include <stdlib.h>
  14. #include <setjmp.h>
  15. #include "config.h"
  16. #include "int.h"
  17. #include "ivars.h"
  18. #include "machinep.h"
  19. #include "farithp.h"
  20. #include "taskingp.h"
  21. #include "predefp.h"
  22. #include "intcp.h"
  23. #include "intbp.h"
  24.  
  25. extern jmp_buf raise_env;
  26.  
  27. static void update_address(int *);
  28. static void image_attribute();
  29. static void value_attribute();
  30. static int same_dimensions(int *, int *);
  31. static int compare_fields_record(int *, int *, int *);
  32.  
  33. void main_attr(int attribute, int dim)                        /*;attribute*/
  34. {
  35.     switch(attribute) {
  36.  
  37.     case ATTR_ADDRESS:
  38.         POP_ADDR(bse, off);
  39.         create(2, &bas1, &off1, &ptr1);/* ADDRESS is a record */
  40.         *ADDR(bas1, off1) = bse;
  41.         *ADDR(bas1, off1 + 1) = off;
  42.         PUSH_ADDR(bas1, off1);
  43.         break;
  44.  
  45.     case ATTR_CALLABLE:
  46.         POP(value);    /* task object */
  47.         value = (is_callable(value));
  48.         PUSH(value);
  49.         break;
  50.  
  51.     case ATTR_COUNT:
  52.         POP(val2);        /* member in family */
  53.         POP(val1);        /* entry family */
  54.         value = count(val1, val2);
  55.         PUSH(value);
  56.         break;
  57.  
  58.     case ATTR_T_CONSTRAINED:
  59.         break;
  60.  
  61.     case ATTR_O_CONSTRAINED:
  62.         break;
  63.  
  64.     case ATTR_T_FIRST:
  65.     case ATTR_T_LAST:
  66.         POP_ADDR(bse, off);/* type */
  67.         ptr = ADDR(bse, off);
  68.         size = SIZE(ptr);
  69.         if (TYPE(ptr) == TT_FX_RANGE) {
  70.             if (attribute == ATTR_T_FIRST)
  71.                 PUSHL(FX_RANGE(ptr)->fxlow);
  72.             else
  73.                 PUSHL(FX_RANGE(ptr)->fxhigh);
  74.         }
  75.         else if (TYPE(ptr) == TT_FL_RANGE) {
  76.             if (attribute == ATTR_T_FIRST)
  77.                 PUSHF(FL_RANGE(ptr)->fllow);
  78.             else
  79.                 PUSHF(FL_RANGE(ptr)->flhigh);
  80.         }
  81.         else if ((TYPE(ptr) == TT_I_RANGE)
  82.           ||     (TYPE(ptr) == TT_E_RANGE)
  83.           ||     (TYPE(ptr) == TT_ENUM)) {
  84.             if (attribute == ATTR_T_FIRST)
  85.                 PUSH(I_RANGE(ptr)->ilow);
  86.             else
  87.                 PUSH(I_RANGE(ptr)->ihigh);
  88.         }
  89. #ifdef LONG_INT
  90.         else if (TYPE(ptr) == TT_L_RANGE) {
  91.             if (attribute == ATTR_T_FIRST)
  92.                 PUSHL(L_RANGE(ptr)->llow);
  93.             else
  94.                 PUSHL(L_RANGE(ptr)->lhigh);
  95.         }
  96. #endif
  97.         else    /* error */
  98.             raise(SYSTEM_ERROR,"Unknown type for attribute FIRST or LAST");
  99.         break;
  100.  
  101.     case ATTR_O_FIRST:
  102.     case ATTR_O_LAST:
  103.         POP_ADDR(bse, off);/* type */
  104.         ptr = ADDR(bse, off);
  105.         POP_ADDR(bas1, off1);/* to get rid of array */
  106.         val1 = *ptr;    /* type of type */
  107.         if (val1 == TT_S_ARRAY) {
  108.             if (attribute == ATTR_O_LAST)
  109.                 value = S_ARRAY(ptr)->sahigh;
  110.             else
  111.                 value = S_ARRAY(ptr)->salow;
  112.             PUSH(value);
  113.         }
  114.         else if (val1 == TT_C_ARRAY || val1 == TT_U_ARRAY) {
  115.             /* Beware: indices in reverse order */
  116.             ptr += 2 * (ARRAY(ptr)->dim - dim);
  117.             bse = ARRAY(ptr)->index1_base;
  118.             off = ARRAY(ptr)->index1_offset;
  119.             ptr = ADDR(bse, off);
  120.             if ((TYPE(ptr) == TT_I_RANGE)
  121.               ||(TYPE(ptr) == TT_E_RANGE)
  122.               ||(TYPE(ptr) == TT_ENUM)) {
  123.                 if (attribute == ATTR_O_LAST)
  124.                     PUSH(I_RANGE(ptr)->ihigh);
  125.                 else
  126.                     PUSH(I_RANGE(ptr)->ilow);
  127.             }
  128. #ifdef LONG_INT
  129.             else if (TYPE(ptr) == TT_L_RANGE) {
  130.                 if (attribute == ATTR_O_LAST)
  131.                     PUSHL(L_RANGE(ptr)->lhigh);
  132.                 else
  133.                     PUSHL(L_RANGE(ptr)->llow);
  134.             }
  135. #endif
  136.         }
  137.         else if (val1 == TT_D_ARRAY) {
  138.             bas1 = D_TYPE(ptr)->dbase;
  139.             off1 = D_TYPE(ptr)->doff;
  140.             ptr += WORDS_D_TYPE + 4 *(dim - 1);
  141.             if (attribute == ATTR_O_LAST)
  142.                 ptr += 2;
  143.             if (*ptr == 0)
  144.                 PUSH(*(ptr + 1));
  145.             else
  146.                 raise(SYSTEM_ERROR, "Attribute on discriminant bound");
  147.         }
  148.         break;
  149.  
  150.     case ATTR_T_LENGTH:
  151.         POP_ADDR(bse, off);
  152.         ptr = ADDR(bse, off);
  153.         size = SIZE(ptr);
  154.         if (size == 1) {
  155.             if (I_RANGE(ptr)->ihigh < I_RANGE(ptr)->ilow)
  156.                 value = 0; 
  157.             else
  158.                 value = I_RANGE(ptr)->ihigh - I_RANGE(ptr)->ilow + 1;
  159.             PUSH(value);
  160.         }
  161. #ifdef LONG_INT
  162.         else /* size=2 */ {
  163.             if (L_RANGE(ptr)->lhigh < L_RANGE(ptr)->llow)
  164.                 lvalue = 0; 
  165.             else
  166.                 lvalue = L_RANGE(ptr)->lhigh - L_RANGE(ptr)->llow;
  167.             PUSHL(lvalue);
  168.         }
  169. #endif
  170.         break;
  171.  
  172.     case ATTR_O_LENGTH:
  173.         POP_ADDR(bse, off);/* type */
  174.         ptr = ADDR(bse, off);
  175.         POP_ADDR(bas1, off1);/* to get rid of array */
  176.         val1 = TYPE(ptr);    /* type of type */
  177.         if (val1 == TT_S_ARRAY) {
  178.             /* the calculation of max is unuseful ! the substraction may
  179.              * produce an overflow and a positive result
  180.              */
  181.             if (S_ARRAY(ptr)->sahigh < S_ARRAY(ptr)->salow)
  182.                 value = 0; 
  183.             else {
  184.                 /*value=MAX(S_ARRAY(ptr)->sahigh-S_ARRAY(ptr)->salow + 1, 0);*/
  185.                 value = S_ARRAY(ptr)->sahigh - S_ARRAY(ptr)->salow + 1;
  186.             }
  187.             PUSH(value);
  188.         }
  189.         else if (val1 == TT_C_ARRAY) {
  190.             /* Beware: indices in reverse order */
  191.             ptr += 2 * (ARRAY(ptr)->dim - dim);
  192.             bse = ARRAY(ptr)->index1_base;
  193.             off = ARRAY(ptr)->index1_offset;
  194.             ptr = ADDR(bse, off);
  195.             /*  value = MAX(I_RANGE(ptr)->ihigh - I_RANGE(ptr)->ilow + 1, 0); */
  196.             if (I_RANGE(ptr)->ihigh < I_RANGE(ptr)->ilow)
  197.                 value = 0; 
  198.             else
  199.                 value = I_RANGE(ptr)->ihigh - I_RANGE(ptr)->ilow + 1;
  200.             PUSH(value);
  201.         }
  202.         break;
  203.  
  204.     case ATTR_T_RANGE:
  205.         POP_ADDR(bse, off);
  206.         ptr = ADDR(bse, off);
  207.         size = SIZE(ptr);
  208.         if (size == 1) {
  209.             PUSH(I_RANGE(ptr)->ilow);
  210.             PUSH(I_RANGE(ptr)->ihigh);
  211.         }
  212. #ifdef LONG_INT
  213.         else /* size == 2 */ {
  214.             lvalue = L_RANGE(ptr)->lhigh - L_RANGE(ptr)->llow;
  215.             PUSHL(lvalue);
  216.         }
  217. #endif
  218.         break;
  219.  
  220.     case ATTR_O_RANGE:
  221.         POP_ADDR(bse, off);/* type */
  222.         ptr = ADDR(bse, off);
  223.         POP_ADDR(bas1, off1);/* to get rid of array */
  224.         val1 = TYPE(ptr);    /* type of type */
  225.         if (val1 == TT_S_ARRAY) {
  226.             val_high = S_ARRAY(ptr)->sahigh;
  227.             val_low = S_ARRAY(ptr)->salow;
  228.             PUSH(val_low);
  229.             PUSH(val_high);
  230.         }
  231.         else if (val1 == TT_C_ARRAY) {
  232.             /*      Beware: indices in reverse order */
  233.             ptr += 2 * (ARRAY(ptr)->dim - dim);
  234.             bse = ARRAY(ptr)->index1_base;
  235.             off = ARRAY(ptr)->index1_offset;
  236.             ptr = ADDR(bse, off);
  237.             size = SIZE(ptr);
  238.             if (size == 1) {
  239.                 PUSH(I_RANGE(ptr)->ilow);
  240.                 PUSH(I_RANGE(ptr)->ihigh);
  241.             }
  242. #ifdef LONG_INT
  243.             else /*(size == 2)*/ {
  244.                 PUSHL(L_RANGE(ptr)->llow);
  245.                 PUSHL(L_RANGE(ptr)->lhigh);
  246.             }
  247. #endif
  248.         }
  249.         break;
  250.  
  251.     case ATTR_IMAGE:
  252.         image_attribute();
  253.         break;
  254.  
  255.     case ATTR_VALUE:
  256.         value_attribute();
  257.         break;
  258.  
  259.     case ATTR_PRED:
  260.         POP_ADDR(bse, off);/* type */
  261.         ptr = ADDR(bse, off);
  262.         if ((TYPE(ptr) == TT_I_RANGE)
  263.           ||(TYPE(ptr) == TT_E_RANGE)
  264.           ||(TYPE(ptr) == TT_ENUM)) {
  265.             POP(value);
  266.             if (value <= I_RANGE(ptr)->ilow)
  267.                 raise(CONSTRAINT_ERROR, "Out of range (PRED)");
  268.             value--;
  269.             PUSH(value);
  270.         }
  271. #ifdef LONG_INT
  272.         else if (TYPE(ptr) == TT_L_RANGE) {
  273.             POPL(lvalue);
  274.             if (lvalue <= L_RANGE(ptr)->llow)
  275.                 raise (CONSTRAINT_ERROR, "Out of range (PRED)");
  276.             lvalue--;
  277.             PUSHL(lvalue);
  278.         }
  279. #endif
  280.         else    /* error */
  281.             raise(SYSTEM_ERROR,"Unknown type for attribute PRED");
  282.         break;
  283.  
  284.     case ATTR_SUCC:
  285.         POP_ADDR(bse, off);/* type */
  286.         ptr = ADDR(bse, off);
  287.         if ((TYPE(ptr) == TT_I_RANGE)
  288.           ||(TYPE(ptr) == TT_E_RANGE)
  289.           ||(TYPE(ptr) == TT_ENUM)) {
  290.             POP(value);
  291.             if (value >= I_RANGE(ptr)->ihigh)
  292.                 raise(CONSTRAINT_ERROR, "Out of range (SUCC)");
  293.             value++;
  294.             PUSH(value);
  295.         }
  296. #ifdef LONG_INT
  297.         else if (TYPE(ptr) == TT_L_RANGE) {
  298.             POPL(lvalue);
  299.             if (lvalue >= L_RANGE(ptr)->lhigh)
  300.                 raise (CONSTRAINT_ERROR, "Out of range (SUCC)");
  301.             lvalue++;
  302.             PUSHL(lvalue);
  303.         }
  304. #endif
  305.         else    /* error */
  306.             raise(SYSTEM_ERROR,"Unknown type for attribute SUCC");
  307.         break;
  308.  
  309.     case ATTR_SIZE:
  310.         POP_ADDR(bse, off);
  311.         ptr1 = ADDR(bse, off);
  312.         value = SIZE(ptr1);
  313.         if ((TYPE(ptr1) == TT_RECORD     
  314.             || TYPE(ptr1) == TT_C_RECORD
  315.              || TYPE(ptr1) == TT_U_RECORD     
  316.             || TYPE(ptr1) == TT_V_RECORD)
  317.             && (U_RECORD(ptr1)->repr_size != 0)) {
  318.            PUSH(U_RECORD(ptr1)->repr_size);
  319.         }    
  320.         else if (TYPE(ptr1) == TT_ACCESS) {
  321.            PUSH(32);
  322.         }    
  323.         else {
  324.            PUSH(value * BITS_SU);
  325.         }
  326.         break;
  327.  
  328.     case ATTR_STORAGE_SIZE:
  329.         POP_ADDR(bse, off);
  330.         ptr1 = ADDR(bse, off);
  331.         if (TYPE(ptr1) == TT_ACCESS) {
  332.